home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CD ROM Paradise Collection 4
/
CD ROM Paradise Collection 4 1995 Nov.iso
/
program
/
swagd_f.zip
/
DIRS.SWG
/
0040_Deletes Subdirs and files.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-02-28
|
17KB
|
509 lines
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* NUKE.PAS by Shane Kerr *
* Deletes a subdirectory and everything it contains. *
* Nuke for DOS written Turbo Pascal 5.5 *
* Nuke for Windows written using Turbo Pascal for Windows 1.0 *
* Version 1.95 November 23, 1991 *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
program Nuke;
uses
{$IFDEF MsDos}
DOS;
{$ENDIF}
{$IFDEF Windows}
WinCRT, WinDOS, Strings;
{$ENDIF}
const
MajorVer = '1'; { Current major version number }
MinorVer = '95'; { Current minor version number }
Year = 1991; { Release year }
{$IFDEF MsDos}
fsDirectory = 64; { Set directory length }
faReadOnly = ReadOnly; { Set directory flags }
faHidden = Hidden;
faSysFile = SysFile;
faVolumeID = VolumeID;
faDirectory = Directory;
faArchive = Archive;
faAnyFile = AnyFile;
{$ENDIF}
{$IFDEF MsDos}
type
TRegisters = Registers; { Used for DOS calls }
TSearchRec = SearchRec; { Used for search record }
{$ENDIF}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* procedure FCBDeleteFile (FileSpec : string);
* Deletes files using the MS-DOS FCB function (from Version 1.0).
* parameters: filespec, file(s) to be deleted
* notes: Can only delete files in the current directory.
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure FCBDeleteFile (filespec : string);
type
TFCB = record
drive : char; { 0 = default, 1 = A, 2 = B }
name : array[0..7] of char; { File name }
ext : array[0..2] of char; { File extension }
curblk : word; { Current block number }
recsize : word; { Logical record size in bytes }
filsize : longint; { File size in bytes }
date : word; { Date file was last written }
resv : array[0..10] of byte; { Reserved for DOS }
currec : byte; { Current record in block }
random : longint; { Random record number }
end;
var
FCB : TFCB;
Regs : TRegisters;
TempStr : string;
NameSeg, NameOfs : word;
FCBSeg, FCBOfs : word;
begin
{ Get segment and offset of the filespec }
TempStr := filespec + chr(0);
NameSeg := seg(TempStr);
NameOfs := ofs(TempStr) + 1;
FCBSeg := seg(FCB);
FCBOfs := ofs(FCB);
{ Do the actual DOS calls }
Regs.AX := $2900;
Regs.DS := NameSeg;
Regs.SI := NameOfs;
Regs.ES := FCBSeg;
Regs.DI := FCBOfs;
MsDos(Regs); { Parse file to FCB }
Regs.DS := FCBSeg;
Regs.DX := FCBOfs;
Regs.AH := $13;
MsDos(Regs); { Delete file (FCB) }
end; { FCBDeleteFile }
{$IFDEF MsDos}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* procedure ClearKb
* Clears the keyboard buffer
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure ClearKb;
var
Regs : TRegisters;
begin
Regs.AH := $01;
Intr($16, Regs);
while ((Regs.Flags and FZero) = 0) do
begin
Regs.AH := $00;
Intr($16, Regs);
Regs.AH := $01;
Intr($16, Regs);
end;
end; { procedure ClearKb }
{$ENDIF}
{$IFDEF MsDos}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* procedure WaitKey
* Waits for a key press
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure WaitKey;
var
Regs : TRegisters;
begin
Regs.AH := $00;
Intr($16, Regs);
end; { procedure WaitKey }
{$ENDIF}
{$IFDEF MsDos}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* function IsRedirected : boolean;
* Determines whether a program's input or output is redirected
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function IsRedirected : boolean;
var
Regs : Registers; { Register values }
StdIn : ^Byte; { Standard input }
StdOut : ^Byte; { Standard output }
begin
Regs.AH := $62; { Get segment address of PSP }
MsDos(Regs);
StdIn := Ptr(Regs.BX, $18); { Point to StdIn value }
StdOut := Ptr(Regs.BX, $19); { Point to StdOut value }
{ Return TRUE if StdIn is the same as StdOut }
IsRedirected := (StdIn^ <> StdOut^);
end;
{$ENDIF}
{$IFDEF MsDos}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* function NumRows : byte;
* Returns the number of rows on the screen
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function NumRows : byte;
var
ScreenWidth : word absolute $0040:$004A;
ScreenSize : word absolute $0040:$004C;
begin
NumRows := (((ScreenSize div 1000) * 1000) div 2) div ScreenWidth;
end;
{$ENDIF}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* function NukeDir (directory : string) : boolean; *
* Destroys the specified directory and all it contains recursively *
* parameters: directory, path of the directory to be destroyed *
* remove, TRUE to remove directory *
* display, TRUE to display files as they are deleted *
* pause, TRUE to pause after each screen *
* attr, file search attributes to delete *
* lines, number of lines displayed so far *
* returns: TRUE if directory is removed, FALSE otherwise *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function NukeDir (directory : string; remove, display, pause : boolean;
attrib : word; var lines : word) : boolean;
var
OrgDir : string[fsDirectory]; { Saved original directory }
SrchRec : TSearchRec; { For file searches }
Dummy : boolean;
Handle : file; { File handle (for attrib change) }
begin
GetDir(0, OrgDir); { Get original directory }
ChDir(directory); { Change to target directory }
{ If display isn't on, just delete everything (grumble) }
if (not display) then
FCBDeleteFile('????????.???'); { Delete all files }
{ Find first file present }
FindFirst('*.*', faDirectory or attrib, SrchRec);
{ Loop and nuke any subdirectories found }
repeat
if (((SrchRec.Attr and faDirectory) <> 0) and (DosError = 0) and
{$IFDEF MsDos}
(SrchRec.Name[1] <> '.')) then
{$ENDIF}
{$IFDEF Windows}
(SrchRec.Name[0] <> '.')) then
{$ENDIF}
begin
Assign(Handle, SrchRec.Name);
SetFAttr(Handle, faDirectory);
Dummy := NukeDir(SrchRec.Name, TRUE, Display, Pause, Attrib, Lines);
end
else if ((DosError = 0) and
{$IFDEF MsDos}
(SrchRec.Name[1] <> '.') and
{$ENDIF}
{$IFDEF Windows}
(SrchRec.Name[0] <> '.') and
{$ENDIF}
(((SrchRec.Attr and Attrib) <> 0) or (Attrib = 0))) then
begin
Assign(Handle, SrchRec.Name);
SetFAttr(Handle, 0);
Erase(Handle);
{ If displaying, then show name and increase line count }
if (Display) then
begin
WriteLn(' Deleting ', Directory, '\', SrchRec.Name);
Inc(Lines);
end;
{ If pausing, check line count }
if (Pause and ((Lines mod (NumRows - 2)) = 0)) then
begin
Write('Press any key to continue...');
WaitKey;
WriteLn;
end;
end; { if block }
FindNext(SrchRec);
until (DosError <> 0);
{ If original directory is current, change to parent }
if (OrgDir = Directory) then
ChDir('..')
else if (pos(Directory, OrgDir) = 1) then
begin
ChDir(Directory);
ChDir('..');
end
else
ChDir(OrgDir); { Restore directory }
NukeDir := FALSE;
if (Remove) then
begin
{$I-}
RmDir(Directory); { Kill target directory }
if (IOResult = 0) then
NukeDir := TRUE;
{$I+}
end;
end; { function NukeDir }
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* function ToUpper (Str : string) : string; *
* Convert string to upper case *
* parameters: Str, any string *
* returns: uppercase value of the string *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function ToUpper (Str : string) : string;
var
i : integer;
Temp : string;
begin
Temp := str;
for i := 1 to length(Str) do
Temp[i] := UpCase(Temp[i]);
ToUpper := Temp;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* function ListFiles (directory : string) : integer *
* Lists files and attributes in the specified directory below *
* parameters: directory, directory to start listing at *
* returns: number of files listed *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function ListFiles (directory : string) : integer;
var
OrgDir : string; { Original directory }
CurDir : string; { Current directory }
SearchRec : TSearchRec; { Used to find filespecs }
NumListed : Integer; { Number of files listed }
Attr: word; { Attributes to remove }
begin
NumListed := 0; { Number of files listed }
GetDir(0, OrgDir); { Get original directory }
ChDir(directory); { Change to target directory }
GetDir(0, CurDir); { Get current directory }
{ Find first directory present }
FindFirst('*.*', faDirectory or faReadOnly or faHidden or faSysFile,
SearchRec);
FindNext(SearchRec);
FindNext(SearchRec);
{ Loop and list any files found }
repeat
if ((DosError = 0) and ((SearchRec.Attr and faDirectory) <> 0)) then
begin
NumListed := NumListed + ListFiles(SearchRec.Name);
end;
if (DosError = 0) then
begin
NumListed := NumListed + 1;
Write(' ', CurDir, '\', SearchRec.Name);
if ((SearchRec.Attr and faDirectory) <> 0) then
Write(', directory');
if ((SearchRec.Attr and faReadOnly) <> 0) then
Write(', read-only');
if ((SearchRec.Attr and faHidden) <> 0) then
Write(', hidden');
if ((SearchRec.Attr and faSysFile) <> 0) then
Write(', system');
WriteLn;
end; { if }
FindNext(SearchRec);
until (DosError <> 0);
ChDir(OrgDir); { Restore directory }
ListFiles := NumListed; { Return number of files listed }
end; { procedure ListFiles }
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
* function HasSwitch (switch : string) : boolean *
* Checks the command-line arguements for the specified switch *
* parameters: switch, the switch to search for *
* returns: TRUE if found, else FALSE *
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function HasSwitch (switch : char) : boolean;
var
i : integer; { Index variable }
begin
HasSwitch := FALSE;
for i := 1 to ParamCount-1 do
begin
if (Pos(UpCase(switch), ToUpper(ParamStr(i))) <> 0) then
begin
HasSwitch := TRUE;
Exit;
end; { if }
end; { for }
end; { function HasSwitch }
var { main variables }
UserInput : string[fsDirectory]; { user response }
Answer : string; { user response }
OrgDir : string[fsDirectory]; { Original directory }
Target : string[fsDirectory]; { Directory to nuke }
Remove : boolean; { If directory actually removed }
Result : boolean; { Result of nuking }
LinesShown : word; { Number of lines shown so far }
Attrib : word; { File attributes to delete }
begin { main program }
{ Print greeting }
WriteLn('NUKE Directory ', MajorVer, '.', MinorVer);
WriteLn(' (C)', Year, ' by Kerr');
WriteLn;
{ Check for DOS help command }
if ((ParamCount < 1) or HasSwitch('?') or (Pos('?', ParamStr(1)) <> 0)) then
begin
Write('Removes a subdirectory, along with the files and ');
WriteLn('subdirectories is contains');
WriteLn;
WriteLn('NUKE [options] [directory]');
WriteLn;
WriteLn('Options are as follows:');
WriteLn(' K Keeps the subdirectory after clearing out files.');
WriteLn(' H Deletes hidden files.');
WriteLn(' R Deletes read-only files.');
WriteLn(' S Deletes system files.');
WriteLn(' A Deletes files of all attributes.');
WriteLn(' Y No verification before NUKEing - dangerous!');
Write (' V Verbose, displays files and subdirectories they ');
WriteLn('are removed - SLOW!');
WriteLn(' P Pause after each screen.');
WriteLn;
WriteLn('You cannot nuke the root directory.');
WriteLn('Nuke will not Pause if you redirect the input or output.');
Exit;
end;
{ Set number of lines displayed }
LinesShown := 0;
{ Check for /K switch }
Remove := not HasSwitch('K');
Attrib := 0;
{ Check for /H switch }
if (HasSwitch('H')) then
Attrib := Attrib or faHidden;
{ Check for /R switch }
if (HasSwitch('R')) then
Attrib := Attrib or faReadOnly;
{ Check for /S switch }
if (HasSwitch('S')) then
Attrib := Attrib or faSysFile;
{ Check for /A switch }
if (HasSwitch('A')) then
if (Attrib <> 0) then
begin
WriteLn('Cannot use the /A switch with other attribute switches.');
Exit;
end
else
Attrib := faAnyFile;
{$IFDEF MsDos}
UserInput := ParamStr(ParamCount);
{$ENDIF}
{$IFDEF Windows}
Write('Input directory to remove: ');
ReadLn(UserInput);
{$ENDIF}
{ Save directory and drive and try to change to new directory }
GetDir(0, OrgDir);
{$I-}
ChDir(UserInput);
if (IOResult <> 0) then
begin
WriteLn(' Specified directory not found!');
ChDir(OrgDir);
Exit;
end;
{$I+}
GetDir(0, Target); { Get new directory }
{ Display target directory and change back from it }
WriteLn(' Target is ', Target);
WriteLn;
ChDir(OrgDir); { Restore directory }
{ Exit if root directory being nuked }
if (length(Target) = 3) then
begin
WriteLn('You cannot NUKE the root directory!');
WriteLn(' (Try FORMAT...)');
Exit;
end;
{ Double check before DECIMATING directory }
if (not HasSwitch('Y')) then
begin
WriteLn(' Are you SURE you want to OBLITERATE this directory and');
Write(' everything in or under it?!?!? (Y/N) ');
{$IFDEF MsDos}
ClearKb;
{$ENDIF}
ReadLn(Answer);
Answer := ToUpper(Answer);
end;
{ If 'yes' or 'y' entered, or 'Y' SWITCH set, nuke that puppy }
if ((answer = 'YES') or (answer = 'Y') or HasSwitch('Y')) then
begin
WriteLn(' Beginning now...');
Result := NukeDir(Target, Remove, HasSwitch('V'),
HasSwitch('P') and (not IsRedirected), Attrib, LinesShown);
WriteLn(' ...may the diety of your choice have mercy on your soul.');
end { if }
else
begin
Result := FALSE;
WriteLn(' Nothing done.');
Exit;
end; { else }
{ List files not deleted }
if (not Result) then
begin
WriteLn;
{ Display a message if the directory was SUPPOSED to be removed }
if (Remove) then
begin
WriteLn(' NUKE failed to remove the directory.');
end
else
begin
WriteLn(' NUKE has kept the directory.');
end;
WriteLn(' The following files or directories remain in it:');
if (ListFiles(Target) = 0) then
WriteLn(' None');
{ Display helpful hint if the directory was SUPPOSED to be removed }
if (Remove) then
begin
WriteLn;
Write('If you wish to remove these files, try the ');
WriteLn('/H, /R, and /S options,');
WriteLn(' or the /A option.');
end;
end; { if }
end. { main }